#! /usr/bin/env tclsh

# Single Threaded Simplistic Site
lappend auto_path C:/tmp/Wub-svn/trunk ;# path to the Site.tcl file
lappend auto_path /target/staff/decoster/tmp/tml/www/Wub ;# path to the Site.tcl file
lappend auto_path /var/www/Wub ;# path to the Site.tcl file
lappend auto_path .

set docroot [pwd]/docroot
set home $docroot

package require Site
package require http
package require picoirc

###### Application Starts Here
#### install directories of static files
foreach {dom expiry} {css {tomorrow} images {next week} scripts {tomorrow} img {next week} html 0 bin 0} {
    File $dom -root [file join $docroot $dom] -expires $expiry
}

#### Honeypot domain captures misbehaving bots
package require Honeypot
set hp [file join /tmp/ captcha]
catch {file mkdir $hp}
Honeypot init dir $hp honeypot /bzzzz captcha /captcha

#### robots: sent as robots.txt
variable robots {User-agent: *
    Disallow: /bzzzz
}

# sortable - include javascripts and CSS for sortable table.
proc sortable {r} {
    foreach js {common css standardista-table-sorting} {
	dict lappend r -headers [<script> type text/javascript src /$js.js {}]
    }
    dict lappend r -headers [<style> type text/css media all "@import url(/sorttable.css);"]
    return $r
}

#### introspection: example of a direct domain
# used to introspect the server
namespace eval ::Introspect {
    # clear the cache
    proc /cclear {r args} {
	Cache clear
	return [Http Redir $r /]
    }

    # report on the cache
    proc /cache {r args} {
	dict lappend r -headers [<title> "Wubchain introspect: cache"]
	set C [Html dict2table [Cache::2dict] {-url -stale -hits -unmod -ifmod -when -size}]
	return [Http NoCache [Http Ok [sortable $r] $C x-text/html-fragment]]
    }

    # report on currently blocked client sites
    proc /block {r args} {
	dict lappend r -headers [<title> "Wubchain introspect: blocked clients"]
	set C [Html dict2table [Block blockdict] {-site -when -why}]
	return [Http NoCache [Http Ok [sortable $r] $C x-text/html-fragment]]
    }

    proc /state {r} {
	dict lappend r -headers [<title> "Wubchain introspect: state"]
	set state [Activity state]
	set result [<table> summary {} class sortable [subst {
	    [<thead> [<tr> [<th> [join {cid socket thread backend ip start end log} </th><th>]]]]
	    [<tfoot> [<tr> [<th> [join {cid socket thread backend ip start end log} </th><th>]]]]
	    [<tbody> [Foreach row $state {
		[<tr> [<td> [join $row </td><td>]]]
	    }]]
	}]]
	
	set r [sortable $r]	;# include the sortable js
	
	return [Http NoCache [Http Ok $r $result]]
    }

    proc /activity {r {L "current"} {F "html"} args} {
	# generate an activity page
	if {$L eq "log"} {
	    set act [Activity log]
	    set title "Wubchain introspection: activity log"
	    set alt [<a> href "/introspect/activity?L=current" "Current server activity:"]
	} else {
	    set act [Activity current]
	    set title "Wubchain introspection: current activity"
	    set alt [<a> href "/introspect/activity?L=log" "Server activity Log"]
	}

	switch -- $F {
	    csv {
		package require csv
		foreach a $act {
		    append result [::csv::joinlist $a] \n
		}
		dict set r content-type text/plain
	    }

	    html -
	    default {
		set table [<table> summary {} class sortable [subst {
		    [<thead> [<tr> [Foreach t [lindex $act 0] {
			[<th> [string totitle $t]]
		    }]]]
		    [<tfoot> [<tr> [Foreach t [lindex $act 0] {
			[<th> [string totitle $t]]
		    }]]]
		    [<tbody> [Foreach a [lrange $act 1 end] {
			[<tr> class [If {[incr row] % 2} even else odd] \
			     [<td> [join $a </td>\n<td>]]]
		    }]]
		}]]
		set result "[<h1> $title]$table[<p> $alt]"
		
		set r [sortable $r]	;# include the sortable js
		dict set r content-type x-text/html-fragment
	    }
	}
	
	return [Http NoCache [Http Ok $r $result]]
    }

    proc /chat_activity { r args } {
	dict lappend r -headers [<title> "Wubchain introspection: chat activity"]
	set C [Html table "Wubchain statistics: activity" [array get ::Wubchain::stats]]
	foreach {k v} [array get ::Wubchain::stats] {
	    dict set d parameter $k
	    dict set d value $v
	    dict set td [incr i] $d
	}
	set C [Html dict2table $td {parameter value}]
	return [Http NoCache [Http Ok [sortable $r] $C x-text/html-fragment]]
    }

    proc /parameters { r args } { 
	dict lappend r -headers [<title> "Wubchain introspection: parameters"]
	foreach v [info vars ::Wubchain::irc_*] {
	    if {[info exists $v]} {
		upvar #0 $v p
		dict set d parameter [armour $v]
		dict set d value [armour $p]
		dict set td [incr i] $d
	    }
	}
	foreach v [info vars ::Wubchain::wubchain_*] {
	    if {[info exists $v]} {
		upvar #0 $v p
		dict set d parameter [armour $v]
		dict set d value [armour $p]
		dict set td [incr i] $d
	    }
	}
	set C [Html dict2table $td {parameter value}]
	return [Http NoCache [Http Ok [sortable $r] $C x-text/html-fragment]]
    }

    proc /overview { r args } {
	dict lappend r -headers [<title> "Wubchain introspection: overview"]
	set C ""
	append C [<h1> "Wubchain introspection:"]
	append C <ul>
	append C [<li> [<a> href /introspect/activity "Server activity"]]
	append C [<li> [<a> href /introspect/block "Blocked clients"]]
	append C [<li> [<a> href /introspect/cache Cache]]
	append C [<li> [<a> href /introspect/chat_activity "Chat activity"]]
	append C [<li> [<a> href /introspect/parameters Parameters]]
	append C [<li> [<a> href /introspect/state State]]
	append C </ul>
	return [Http Ok $r $C x-text/html-fragment]
    }

    proc / { r args } { 
	return [/overview $r {*}$args]
    }

    namespace export -clear {*}
    namespace ensemble create -subcommands {}
}

Direct init introspect namespace ::Introspect prefix /introspect/ ctype "x-text/html-fragment"

Direct init webdirect namespace ::Wubchain

namespace eval ::Wubchain {

    variable irc_encoding  iso8859-1
    variable irc_server    irc.freenode.org
    variable irc_port      6667
    variable irc_chan      #tcl

    variable wubchain_nposts 1000 ;# Number of posts to keep
    variable wubchain_sys_nick_list {- tcl@tach.tclers.tk} ;# Do not regard messages from these users as new posts
    variable wubchain_bridge_nick_list {azbridge ijchain ijtest}

    variable wubchain_nick_css_url http://tkchat.tcl.tk/usercolors.css 
    variable wubchain_nick_css_update_interval 3600 ;# in seconds
    variable wubchain_nick_css ""
    variable wubchain_admin "jos_dot_decoster_at_gmail_dot_com"

    variable user_online

    variable stats

    set stats(posts_from_irc) 0
    set stats(posts_from_wubchain) 0
    set stats(gets_from_wubchain) 0
    set stats(last_post_time_stamp) 0

    expr srand([pid]) ;# set rand seed for session-id generation
    
    variable htmlhead {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1.dtd">}
    variable language "en"
    
    variable head {
	<style type='text/css'>p {padding: 0px; margin: 0px;} div.nick_post {background: yellow;} div.my_post {background: #ccddff;} form {padding: 0px; margin: 0px;}</style>
    }
    
    proc SmileId { name n triggers } {
	variable IMG
	variable IMGre
	foreach arg $triggers {
	    set IMG($arg) $name
	    if { [string is alnum -strict -failindex i $arg] } {
		lappend ids "\1$arg\2"
	    } elseif { [string is alnum -strict [string index $arg end]] } {
		if {$i > 0} {
		    lappend ids "\1$arg\2"
		} else {
		    lappend ids "\3$arg\2"
		}
	    } else {
		if {$i > 0} {
		    lappend ids "\1$arg"
		} else {
		    lappend ids "\3$arg"
		}
	    }
	}
	set ids [join $ids "\0"]
	set map [list \
		     |   \\|		(   \\(		)   \\)		\[   \\\[	\
		     -   \\-		.   \\.		*   \\*		?    \\?	\
		     \\  \\\\	^   \\^		$   \\$		\1   \\m	\
		     \2  \\M		\3  \\Y		\0  |				\
		    ]
	# If we ever change this to use () capturing, change tkchat::Insert too.
	if { [info exists IMGre] } {
	    append IMGre |[string map $map $ids]
	} else {
	    set IMGre [string map $map $ids]
	}
    }

    SmileId cry 1 {":-(" ":^(" ":("}
    SmileId grrr 1 {"8-(" "8^(" "8(" "8-|" "8^|" "8|"}
    SmileId LOL-anim 1 {LOL lol}
    SmileId mad 1 {">:(" ">:-(" ">:^("}
    SmileId oh 1 {":-o" ":^o" ":o" ":-O" ":^O" ":O"}
    SmileId smile 1 {":-)" ":^)" ":)"}
    SmileId smile-big 1 {":-D" ":^D" ":D"}
    SmileId smile-dork 1 {"<:-)" "<:^)" "<:)"}
    SmileId smile-glasses 1 {"8-)" "8^)" "8)"}
    SmileId smile-tongue-anim 1 {":-p" ":^p" ":p"}
    SmileId smirk-glasses 1 {";/" ";-/" ";^/" ":/" ":-/" ":^/" "8/" "8-/" "8^/"}
    SmileId tongue2 1 {":-P" ":^P" ":P"}
    SmileId updown 1 {"(:" "(^:" "(-:"}
    SmileId wink-anim 1 {";-)" ";^)" ";)"}
    SmileId blush 1 {":-\}" ":^\}" ":8\}" ":\}"}
    SmileId coffee 1 LP
    SmileId lunch 1 {|O| |o| |0|}
    SmileId snooze 1 {zz zzz zzZ zZZ ZZZ ZZ}
    SmileId beer 1 "|_P"
    SmileId cyclops 1 {"O-\]" "O-)" "0-\]" "0-)"}    
    SmileId donuts 1 "donuts"
    SmileId bug 1 {"bug #" "bug#"}
    SmileId wave 2 {~~~ waves}
    SmileId phone 3 {"on the phone"}
    SmileId yawn 3 {yawn yawns}
    SmileId applause 2 {applause applauds}

    proc load_user { user } {
	set fnm [file join docs user-$user.dat]
	set f [open $fnm r]
	set u [string trim [lindex [split [read $f] \n] 0]]
	close $f
	set nuser {}
	if {[string length $u] } {
	    if { [llength $u] == 2 } {
		lappend nuser {*}$u 30 0
	    } elseif { [llength $u] == 4 } {
		lappend nuser {*}$u
	    }
	}
	return $nuser
    }

    proc save_user {user pwd cnt gr} {
	set fnm [file join docs user-$user.dat]
	set f [open $fnm w]
	puts $f "\{$user\} \{$pwd\} $cnt $gr"
	close $f
    }

    proc create_nick_css { } {
	variable wubchain_nick_css_url
	variable wubchain_nick_css

	if {[string length $wubchain_nick_css_url] == 0} {
	    return
	}

	if {[catch {http::geturl $wubchain_nick_css_url} tkn]} {
	    Debug.error {create_nick_css: $tkn}
	    return
	}
	
	if {[http::ncode $tkn] == 200} {
	    set wubchain_nick_css "<style type='text/css'>"
	    append wubchain_nick_css [regsub -all {span\.} [http::data $tkn] {div.}]
	    append wubchain_nick_css "</style>"
	}

	http::cleanup $tkn
    }

    proc m { mt mn mm } {
	variable ulog
	variable ulogid
	variable history_SID
	variable wubchain_bridge_nick_list
	if {[in $wubchain_bridge_nick_list $mn]} {
	    set idx [string first " " $mm]
	    if { $idx >= 0 } { 
		set mn [string trim [string range $mm 0 $idx-1] "<>"]
		set mm [string range $mm $idx+1 end]
	    } else {
		set mn $mm
		set mm ""
	    }
	}
	if {[regexp {^/me (.+)} $mm -> mm]} {
	    set prep <i>
	    set postp </i>
	} else {
	    set prep ""
	    set postp ""
	}
	foreach l [split $mm \n] {
	    set amm "$prep[armour $l]$postp<br />"
	    set hmm "$prep[hfrmt $l]$postp<br />"
	    lappend ulog($history_SID) [incr ulogid($history_SID)] [clock scan $mt -format {%Y-%m-%dT%H:%M:%SZ}] [armour $mn]: $amm $hmm
	}
    }

    proc load_history { SID } {
	variable ulog
	variable wubchain_nposts
	variable history_SID $SID
	foreach t {yesterday today} {
	    set url "http://tclers.tk/conferences/tcl/[clock format [clock scan $t] -format {%Y-%m-%d}].tcl"
	    if {[catch {http::geturl $url} tkn]} {
		Debug.error {load_history: $tkn}
		continue
	    }
	    if {[http::ncode $tkn] == 200} {
		eval [http::data $tkn]
	    }
	    http::cleanup $tkn
	}
	set ulog($SID) [lrange $ulog($SID) end-[expr {$wubchain_nposts*5-1}] end]
	unset history_SID
    }
    
    proc make_href {url} {
	return "<a href='[armour $url]'>[armour $url]</a>"
    }

    proc make_iref {emo} {
	variable IMG
	return "<img src='/$IMG($emo).gif' alt='[armour $emo]' />"
    }

    proc sfrmt {msg} {
	variable IMGre
	set i 0
	set hmsg ""
	foreach match [regexp -inline -all -indices -- $IMGre $msg] {
	    lassign $match start end
	    set emo [string range $msg $start $end]
	    append hmsg [armour [string range $msg $i [expr {$start-1}]]]
	    append hmsg [make_iref $emo]
	    set i [expr {$end+1}]
	}	
	if { $i <= [string length $msg] } {
	    append hmsg [armour [string range $msg $i end]]
	}
	return $hmsg
    }

    proc hfrmt {msg} {
	set i 0
	set n 0
	set hmsg ""
	foreach match [regexp -inline -all -indices -- {(https?|ftp|news|mailto|file):([^\s:]\S*[^\]\)\s\.,!\?;:'>"])} $msg] { ;# "
	    if { $n % 3 == 0 } {
		lassign $match start end
		set url [string range $msg $start $end]
		append hmsg [sfrmt [string range $msg $i [expr {$start-1}]]]
		append hmsg [make_href $url]
		set i [expr {$end+1}]
	    }
	    incr n
        }
	if { $i <= [string length $msg] } {
	    append hmsg [sfrmt [string range $msg $i end]]
	}
	return $hmsg
    }

    proc in {list element} {
	expr {[lsearch -exact $list $element]>=0}
    }

    proc PicoIrcConnect { user cnt gr} {
	variable irc_server
	variable irc_port
	variable irc_chan
	variable ulog
	variable ulogid
	variable user_online
	set url irc://$irc_server
	append url : $irc_port / $irc_chan
	set context [picoirc::connect ::Wubchain::PicoIrcCallback $user $url]
	upvar #0 $context irc
	set ircuser $irc(nick)
	set sid [format %08x%08x%08x%08x [expr int(rand()*0xffffffff)] [expr int(rand()*0xffffffff)] [expr int(rand()*0xffffffff)] [expr int(rand()*0xffffffff)]]
	set irc(sid) $sid
	set ulog($sid) {0 0 wubchain Welcome. Welcome.}
	set ulogid($sid) 0
	set user_online($sid,user) $user 
	set user_online($sid,ircuser) $ircuser 
	set user_online($sid,ctxt) $context
	set user_online($sid,cnt) $cnt
	set user_online($sid,gr) $gr
	set user_online($sid,id) 0
	return $sid
    }
	
    proc PicoIrcPost {sid msg} {
	variable user_online
	::picoirc::Post $user_online($sid,ctxt) $msg
    }

    proc PicoIrcCallback {context state args} {
	variable ulog
	variable ulogid
	variable wubchain_sys_nick_list
	variable wubchain_bridge_nick_list
	variable stats
	upvar #0 $context irc
	set sid $irc(sid)
	puts "callback: context = $context"
	puts "          state   = $state"
	puts "          args    = $args"
	switch -exact -- $state {
	    init {
		puts "init: $args"
		foreach msg [split [join $args] \n] {
		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%init%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
		}
	    }
	    connect {
		puts "connect: $args"
		foreach msg [split [join $args] \n] {
		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%connect%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
		}
	    }
	    close {
		puts "close: $args"
		foreach msg [split [join $args] \n] {
		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%close%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
		}
	    }
	    userlist {
		foreach nick [lindex $args 0] {
		    puts "userlist: $nick"
		}
		foreach msg [split [join $args] \n] {
		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%userlist%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
		}
	    }
	    chat {
		lassign $args nick msg type

		puts "nick = $nick"
		puts "msg = $msg"
		puts "type = $type"

		lappend ulog($sid) [incr ulogid($sid)] [clock seconds]
		if {$type eq ""} {set type NORMAL}
		if {$type eq "ACTION"} {
		    if [in $wubchain_bridge_nick_list $nick] {
			set nick [lindex $msg 0]
			set msg [lrange $msg 1 end]
		    }
		    lappend ulog($sid) *[armour $nick]		    
		} elseif [in $wubchain_bridge_nick_list $nick] {
		    regexp {<([^>]+)>(.+)} $msg -> nick msg
		    lappend ulog($sid) [armour $nick]:	    
		} else {
		    lappend ulog($sid) [armour $nick]:	    
		}
		set pmsg {}
		set gmsg {}
		foreach msgl [split $msg "\n"] {
		    if {$type eq "ACTION"} {
			lappend pmsg <i>[armour $msgl]</i>
			lappend gmsg <i>[hfrmt $msgl]</i>
		    } else {
			lappend pmsg [armour $msgl] 
			lappend gmsg [hfrmt $msgl]
		    }
		}
		set jpmsg [join $pmsg "<br />"]
		set jgmsg [join $gmsg "<br />"]
		lappend ulog($sid) "$jpmsg<br />" "$jgmsg<br />"
		incr stats(posts_from_irc)
		if {![in $wubchain_sys_nick_list $nick]} { 
		    set stats(last_post_time_stamp) [clock seconds]
		}
	    }
	    system {
		puts "system: $args"
#		foreach msg [split [join $args] \n] {
#		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%system%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
#		}
	    }
	    topic {
		puts "topic: $args"
		foreach msg [split [join $args] \n] {
		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%topic%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
		}
	    }
	    traffic {
		puts "traffic: $args"
		foreach {action nick new} $args break
		if {$action eq "nickchange"} {
		    set nick [list $nick $new]
		    puts "  nickchanges: $nick"
		}
		foreach msg [split [join $args] \n] {
		    lappend ulog($sid) [incr ulogid($sid)] [clock seconds] "%traffic%" "[armour $msg]<br />" "[hfrmt $msg]<br />"
		}
	    }
	    default {
		puts "unknown irc callback \"$state\": $args"
	    }
	}
    }
	    
	    proc sendPage { r C {title Wubchain} } {
	variable htmlhead
	variable language
	variable head
	variable wubchain_nick_css
	set content "${htmlhead}\n"
	append content "<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='$language' lang='$language'>" \n
	append content <head> \n
	if {[dict exists $r -headers]} {
	    append content [join [dict get $r -headers] \n] \n
	    dict unset r -headers
	}
	append content <title> $title </title>
	append content $head
	append content $wubchain_nick_css
	append content </head> \n
	append content <body> \n
	append content $C \n
	append content </body> \n
	append content </html> \n

	# Send the page
	set r [dict replace $r \
		   -content $content \
		   -raw 1 \
		   content-type text/html]
	set r [Http NoCache $r]
	set r [Http Ok $r]

	return $r
    }

    proc unescape str {
#	set str [string map [list + { } "\\" "\\\\"] $str]
#	regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str
#	set str [subst -novariable -nocommand $str]
	set str [encoding convertfrom utf-8 $str]
	string trim $str
    }

    proc /post { r MSG SID gobutton sbutton  } {
	variable ulog
	variable ulogid
	variable stats
	variable wubchain_nposts
	variable user_online

	# Check user/session
	if { ![online $SID] } {
	    return [please_login $r]
	}

	# S button clicked, redirect to settings page
	if { [string tolower $sbutton] eq "s" } {
	    return [Http Redir $r "http://[dict get $r host]/settings" SID $SID]
	}

	# Post message
	set MSG [unescape $MSG]
	set aNICK [armour $user_online($SID,user)]
	if { [string length $MSG] } {
	    if { 0 } { 
		if [regexp {^/me (.+)} $MSG -> action] {
		    lappend ulog($SID) [incr ulogid($SID)] [clock seconds] $aNICK "<i>[armour $action]</i><br />" "<i>[hfrmt $action]</i><br />"
		} else {
		    lappend ulog($SID) [incr ulogid($SID)] [clock seconds] $aNICK "[armour $MSG]<br />" "[hfrmt $MSG]<br />"
		}
		set ulog($SID [lrange $ulog($SID) end-[expr {$wubchain_nposts*5-1}] end]
		incr stats(posts_from_wubchain)
		set stats(last_post_time_stamp) [clock seconds]
	    }
	    PicoIrcPost $SID $MSG
	}

	# Redirect to /get to display posted message
	return [Http Redir $r "http://[dict get $r host]/get#end" SID $SID]
    }

    proc /get { r MSG SID } {
	variable ulog
	variable ulogid
	variable stats
	variable user_online

	# Check user/session
	if { ![online $SID] } {
	    return [please_login $r]
	}

	# Create response contents
	set CNT $user_online($SID,cnt)
	set GR $user_online($SID,gr)
	set ID $user_online($SID,id)
	set C ""
	set NICK $user_online($SID,user)
	set aNICK [armour $user_online($SID,user)]
	set hrdone 0
	foreach {id ts nick post hpost} [lrange $ulog($SID) end-[expr {$CNT*5-1}] end] {
	    set style [string trim nick_$nick :]
	    if { "*$NICK" eq $nick || "$NICK:" eq $nick } {
		set bgprep "<div class='my_post'>"
		set bgpostp "</div>"
	    } elseif { [string first $NICK $post] >= 0 } {
		set bgprep "<div class='nick_post'>"
		set bgpostp "</div>"
	    } else {
		set bgprep ""
		set bgpostp ""
	    }
	    if { $id > $ID && !$hrdone } {
		append C "<hr />\n"
		set hrdone 1
	    }
	    if { $GR } {
		append C "<div><div class='$style'>$bgprep<b>$nick</b> $hpost$bgpostp</div></div>\n"
	    } else {
		append C "<div><div class='$style'>$bgprep<b>$nick</b> $post$bgpostp</div></div>\n"
	    }
	}
	append C "<hr/><form id='cpost' action='/post' method='get'><div>"
	append C "<input name='gobutton' id='gobutton' type='submit' value='Go' />"
	append C "<a href='/settings?SID=$SID'>Setup</a>"
	append C "<input id='cmsg' name='MSG' size='128' value='[armour $MSG]' />"
	append C "<input id='sid' type='hidden' name='SID' value='$SID' />"
	append C "</div></form><div><a id='end'></a></div>"

	# Create response
	set user_online($SID,id) $ulogid($SID)
	incr stats(gets_from_wubchain)
	return [sendPage $r $C]
    }

    proc online { SID } { 
	variable user_online
	if { ![info exists user_online($SID,user)] } {
	    return 0
	}
	return 1
    }

    proc please_login { r } {
	return [Http Redir $r "http://[dict get $r host]/login"]
    }

    proc /settings { r SID } {
	variable ulog
	variable ulogid
	variable stats
	variable user_online

	if { ![online $SID] } {
	    return [please_login $r]
	}

	set C ""
	append C [<h1> "Wubchain user settings:"]
	append C "<hr/><form id='cpost' action='/settings/post' method='get'><table summary=''>"
	append C "<tr><td>Number of lines to display: </td><td><input id='ccnt' name='CNT' size='10' value='$user_online($SID,cnt)' /></td></tr>"
	append C "<tr><td>Use emoticons and detect URLs: </td><td><input type='checkbox' id='cgr' name='GR' value='1'"
	if {$user_online($SID,gr)} {
	    append C " checked='checked'" 
	}
	append C "/></td></tr></table><div>"
	append C "<input id='sid' type='hidden' name='SID' value='$SID' />"
	append C "<input name='gobutton' id='gobutton' type='submit' value='Save settings' />"
	append C "</div></form>"
	append C "<hr /><ul>"
	append C [<li> [<a> href /logout?SID=$SID "Log-out"]]
	append C [<li> [<a> href /clogin?SID=$SID "Change password"]]
#	append C [<li> [<a> href /introspect "Introspection"]]
	append C [<li> [<a> href /get?SID=$SID "Back to chat"]]
	append C </ul>
#	return [Http Ok $r $C x-text/html-fragment]
	sendPage $r $C "Wubchain user settings"
    }

    proc /settings/post { r SID CNT GR } {

	variable user_online

	# Check user/session
	if { ![online $SID] } {
	    return [please_login $r]
	}

	if { ![string is integer -strict $CNT] } { set CNT 30 }
	if { ![string is integer -strict $GR] } { set GR 0 }

	set user_online($SID,cnt) $CNT
	set user_online($SID,gr) $GR

	if {[catch {load_user $user_online($SID,user)} user] } {
	    return [sendPage $r "Faile to save settings: $user"]
	}

	lassign $user u p c g

	if {[catch {save_user $u $p $CNT $GR} R]} {
	    return [sendPage $r "Faile to save settings: $R"]
	}

	return [Http Redir $r "http://[dict get $r host]/get#end" SID $SID]
    }

    proc /login { r } {
	variable wubchain_admin
	set R "<h1>Login for wubchain</h1>"
	append R "<form id='cpost' action='/login/post' method='get'>"
	append R "<table summary=''>"
	append R "<tr><td>Nick: </td><td><input id='username' name='U' size='20' value='' /></td></tr>"
	append R "<tr><td>Password: </td><td><input id='password' type='password' name='P' size='20' value='' /></td></tr>"
	append R "</table>"
	append R "<p><input id='gobutton' type='submit' value='Login' /></p>"
	append R "</form>"
	append R "<p><br /><br />If you don't have a login, please contact <i>$wubchain_admin</i>.</p>"
	return [sendPage $r $R]
    }

    proc /clogin { r SID } {

	if { ![online $SID] } {
	    return [please_login $r]
	}

	set R "<h1>Change password for wubchain</h1>"
	append R "<form id='cpost' action='/clogin/post' method='get'>"
	append R "<table summary=''>"
	append R "<tr><td>Old password: </td><td><input id='password0' type='password' name='P0' size='20' value='' /></td></tr>"
	append R "<tr><td>New password: </td><td><input id='password1' type='password' name='P1' size='20' value='' /></td></tr>"
	append R "<tr><td>New password: </td><td><input id='password2' type='password' name='P2' size='20' value='' /></td></tr>"
	append R "</table>"
	append R "<p><input id='sid' type='hidden' name='SID' value='$SID' />"
	append R "<input id='gobutton' type='submit' value='Login' /></p>"
	append R "</form>"
	return [sendPage $r $R]
    }

    proc /login/post { r U P } {
	variable user_online
	set U [string trim [unescape $U]]
	set P [string trim [unescape $P]]
	if {[string trim $U] eq ""} {
	    set R "Login failed: invalid username."
	    return [sendPage $r $R]
	} 
	if {[string trim $P] eq ""} {
	    set R "Login failed: invalid password."
	    return [sendPage $r $R]
	}
	set ufound 0
	set found 0

	if {[catch {load_user $U} user] } {
	    set R "Login failed: $user"
	    return [sendPage $r $R]
	}

	lassign $user u p cnt gr
	
	if {$u eq $U && $p eq $P} {
	    set found 0
	    foreach k [array names user_online "*,user"] {
		if { $user_online($k) eq $U } { 
		    set sid [string range $k 0 [expr {[string first "," $k] - 1}]]
		    set found 1
		    break
		}
	    }
	    if { !$found } { 
		set sid [PicoIrcConnect $U $cnt $gr]
		load_history $sid
	    }
	    return [Http Redir $r "http://[dict get $r host]/get#end" SID $sid]
	}
	set R "Login failed."
	return [sendPage $r $R]
    }

    proc /clogin/post { r SID P0 P1 P2 } {

	variable users
	variable user_online

	if { ![online $SID] } {
	    return [please_login $r]
	}

	set P0 [string trim [unescape $P0]]
	set P1 [string trim [unescape $P1]]
	set P2 [string trim [unescape $P2]]

	if {[string trim $P0] eq ""} {
	    set R "Login failed: invalid old password."
	    return [sendPage $r $R]
	}
	if {[string trim $P1] eq ""} {
	    set R "Login failed: invalid new password."
	    return [sendPage $r $R]
	}
	if {[string trim $P2] eq ""} {
	    set R "Login failed: invalid new password."
	    return [sendPage $r $R]
	}
	if {$P1 ne $P2} {
	    set R "Login failed: new passwords are not equal."
	    return [sendPage $r $R]
	}
	if {$P0 eq $P1} {
	    set R "Login failed: password did not change."
	    return [sendPage $r $R]
	}

	if {[catch {load_user $user_online($SID,user)} user] } {
	    set R "Login failed: $user"
	    return [sendPage $r $R]
	}

	lassign $user u p cnt gr
	if {$P0 ne $p} {
	    set R "Login failed: invalid password."
	    return [sendPage $r $R]
	}

	if {[catch {save_user $user_online($SID,user) $P1 $user_online($SID,cnt) $user_online($SID,gr)} R]} {
	    return [sendPage $r "Failed to save password: $R"]
	}

	return [Http Redir $r "http://[dict get $r host]/get#end" SID $SID]
    }

    proc /logout {r SID} {
	variable ulog
	variable ulogid
	variable users
	variable user_online

	if { ![online $SID] } {
	    return [please_login $r]
	}

	PicoIrcPost $SID /quit
	unset ulog($SID)
	unset ulogid($SID)
	unset user_online($SID,user)
	unset user_online($SID,ircuser)
	unset user_online($SID,ctxt)
	unset user_online($SID,cnt)
	unset user_online($SID,gr)
	unset user_online($SID,id)
	return [Http Redir $r "http://[dict get $r host]/get"]
    }
}

# Responder::post - postprocess response by converting
proc Responder::post {rsp} {
    return [::Convert do $rsp]
}

# Incoming - indication of incoming request
proc Incoming {req} {

    # fetch cookies
    set req [Cookies 4Server $req]

    Debug.log "Incoming: $req"

    Responder Incoming $req -glob -- [dict get $req -path] {

	/ {
	    Http Redir $req "http://[dict get $req host]/login"
	}

	/clogin -
	/clogin/ -
	/clogin/post -
	/clogin/post/ -
	/get - 
	/get/ - 
	/login -
	/login/ -
	/login/post -
	/login/post/ -
	/logout -
	/logout/ -
	/post - 
	/post/ -
	/settings - 
	/settings/ -
	/settings/post - 
	/settings/post/ {
	    ::webdirect do $req
	}

	/*.php -
	/*.wmv -
	/*.exe -
	/cgi-bin/* {
	    # attempted access to non-existent files indicates a malicious bot
	    # block the originator by IP
	    Block block [dict get $req -ipaddr] "Bogus URL '[dict get $req -path]'"
	    Send [Http Forbidden $req]
	    continue	;# process next request, this one's dealt with
	}

	/introspect/* -
	/introspect {
	    ::introspect do $req
	}

	/*.jpg -
	/*.gif -
	/*.png -
	/favicon.ico {
	    # silently redirect image files - strip all but tail
	    dict set req -suffix [file tail [dict get $req -path]]
	    ::images do $req
	}
	
	/css/*.css -
	/*.css {
	    # silently redirect css files
	    dict set req -suffix [file tail [dict get $req -path]]
	    ::css do $req
	}

	/*.gz {
	    # silently redirect gz files
	    dict set req -suffix [file tail [dict get $req -path]]
	    ::bin do $req
	}

	/robots.txt {
	    variable robots
	    Http Ok $req $robots text/plain
	}

	/*.js {
	    # silently redirect js files
	    dict set req -suffix [file tail [dict get $req -path]]
	    ::scripts do $req
	}

	default {
	    Http NotFound $req
	}
    }
}

proc every {ms body} {after $ms [info level 0]; eval $body}

# Create css
every [expr {$::Wubchain::wubchain_nick_css_update_interval*1000}] Wubchain::create_nick_css

puts "pid=[pid]"

Debug off http 20
Debug off socket 10
Debug off direct 10

# Start Site Server(s)
Site start docroot $docroot home $docroot listener {-port 30008} scgi {-port 0} cmdport 30011
